home *** CD-ROM | disk | FTP | other *** search
/ Aminet 25 / Aminet 25 (1998)(GTI - Schatztruhe)[!][Jun 1998].iso / Aminet / util / pack / xpk_Source.lha / xpk_Source / Oberon / examples / xpk.mod next >
Text File  |  1998-02-08  |  8KB  |  319 lines
  1. (*************************************************************************
  2.  
  3. :Program.    Xpk.mod
  4. :Contents.   General XPK file-to-file packer/unpacker
  5. :Author.     Hartmut Goebel [hG]
  6. :Language.   Oberon
  7. :Translator. Amiga Oberon V2.14
  8. :History.    V0.9, 09 Jan 1992 Hartmut Goebel [hG]
  9. :Date.       06 Aug 1992 00:01:50
  10.  
  11. *************************************************************************)
  12.  
  13. MODULE Xpk;
  14.  
  15. IMPORT
  16.   NoGuru, io,
  17.   arg:= Arguments,
  18.   d  := Dos,
  19.   e  := Exec,
  20.   ol := OberonLib,
  21.   pf := Printf,
  22.   s  := SYSTEM,
  23.   str:= Strings,
  24.   u  := Utility,
  25.   xpk:= XpkMaster;
  26.  
  27. VAR
  28.   argc, c, i: INTEGER;
  29.   Arg, Password, Method, NameBuf: e.STRING;
  30.   ChunkHook: u.Hook;
  31.   suffix, force, unpack, recurse, error: BOOLEAN;
  32.   tags: u.Tags8;
  33.   ErrBuf: ARRAY xpk.errMsgSize+1 OF CHAR;
  34.   BaseName: ARRAY 40 OF CHAR;
  35.  
  36. CONST
  37.   a5 = 13;
  38.  
  39.   Usage = "Usage: XPK [-frsu] [-p password] [-m method] files\n"
  40.           "       -m = four letter packing method name\n"
  41.           "       -f = force packing of already packed files\n"
  42.           "       -s = add suffix and don't delete original\n"
  43.           "       -r = recursively (un)pack files in dir\n"
  44.           "       -u = unpack files\n"
  45.           "       -p = encrypt/decrypt using password";
  46.  
  47.   pTags = u.Tags8(
  48.     xpk.inName,      NIL,
  49.     xpk.outName,     NIL,
  50.     xpk.chunkHook,   NIL,
  51.     xpk.getError,    NIL,
  52.     xpk.findMethod,  NIL,
  53.     xpk.password,    NIL,
  54.     xpk.noClobber,   e.true,
  55.     u.done,0);
  56.  
  57.   tInName = 0;     tOutName = 1;  tChunkHook = 2; tGetError = 3;
  58.   tFindMethod = 4; tPassword = 5; tNoClobber = 6;
  59.  
  60. TYPE
  61.   DirEntryPtr = POINTER TO DirEntry;
  62.   DirEntry = STRUCT
  63.     next: DirEntryPtr;
  64.     name: ARRAY 120 OF CHAR;
  65.   END;
  66.  
  67.  
  68. PROCEDURE End(text: ARRAY OF CHAR);
  69. BEGIN
  70.   io.WriteString(text); io.WriteLn;
  71.   HALT(10);
  72. END End;
  73.  
  74. PROCEDURE ChunkFunc*(myHook{8}: u.HookPtr;
  75.                      object{10}: e.APTR;
  76.                      message{9}: e.APTR): LONGINT;
  77. (* $SaveRegs+  Don't know if we need it, but nothing to loose *)
  78. VAR
  79.   prog: xpk.XpkProgressPtr;
  80. BEGIN
  81. (*  $IF SmallData *)
  82.   s.SETREG(a5,myHook.data); (*  We need the pointer to the global vars in A5 *)
  83. (* $END *)
  84.  
  85.   prog := message;
  86.  
  87.   IF prog.type = xpk.progStart THEN
  88.     pf.Printf0("\033[0 p"); END;
  89.  
  90.   IF prog.type # xpk.progEnd THEN
  91.     pf.Printf6("\r%4s: %-8s (%3ld%% done, %2ld%% CF, %6ld cps) %s\033[K",
  92.                prog.packerName,  prog.activity,   prog.done,
  93.                prog.cf,          prog.speed,      prog.fileName);
  94.   ELSE
  95.     pf.Printf6("\r%4s: %-8s (%3ldK, %2ld%% CF, %6ld cps) %s\033[K\n",
  96.                prog.packerName,  prog.activity,   prog.uLen DIV 1024,
  97.                prog.cf,          prog.speed,      prog.fileName);
  98.   END;
  99.  
  100.   IF prog.type = xpk.progEnd THEN
  101.     pf.Printf0("\033[1 p"); END;
  102.  
  103.   RETURN s.VAL(LONGINT,e.SetSignal(LONGSET{},LONGSET{d.ctrlC}) * LONGSET{d.ctrlC});
  104. END ChunkFunc;
  105.  
  106.  
  107. PROCEDURE GetBaseName(name: ARRAY OF CHAR);
  108. VAR
  109.   ret, len: INTEGER;
  110. BEGIN
  111.   len := 0; ret := 0;
  112.   WHILE name[len] # CHR(0) DO
  113.     CASE name[len] OF "/", ":": ret := len+1; ELSE END;
  114.     INC(len);
  115.   END;
  116.   str.Cut(name,ret,SIZE(BaseName),BaseName);
  117.   str.Upper(BaseName);
  118. END GetBaseName;
  119.  
  120.  
  121. PROCEDURE TempName(VAR name: ARRAY OF CHAR);
  122. VAR
  123.   ret, len: INTEGER;
  124. BEGIN
  125.   COPY(name,NameBuf);
  126.   len := str.Length(name);
  127.   LOOP
  128.     IF len <= 0 THEN EXIT; END;
  129.     DEC(len);
  130.     CASE name[len] OF "/", ":": EXIT; ELSE END;
  131.   END;
  132.   CASE name[len] OF "/", ":": INC(len); ELSE END;
  133.   name[len] := CHR(0);
  134.   pf.SPrintf1(name,"tmp%lx",s.ADR(name));
  135. END TempName;
  136.  
  137.  
  138. PROCEDURE DoFile(filename: ARRAY OF CHAR): BOOLEAN;
  139. VAR
  140.   fib: xpk.XpkFib;
  141.   buf: ARRAY 100 OF CHAR;
  142.   len: INTEGER;
  143.   help: ARRAY 6 OF CHAR;
  144. BEGIN
  145.   IF ~force OR unpack THEN
  146.     IF xpk.ExamineTags(fib,xpk.inName,s.ADR(filename),u.done) # 0 THEN
  147.       io.WriteString("Error examining "); io.WriteString(filename); io.WriteLn;
  148.       RETURN FALSE;
  149.     END;
  150.   END;
  151.  
  152.   TempName(filename);
  153.   IF ~unpack THEN
  154.     IF ~force & (fib.type # xpk.typeUnpacked) THEN
  155.       io.WriteString("Skipping (already packed) ");
  156.       io.WriteString(filename); io.WriteLn;
  157.       RETURN FALSE;
  158.     END;
  159.  
  160.     IF suffix THEN
  161.       pf.SPrintf1( NameBuf, "%s.xpk", s.ADR(filename)); END;
  162.  
  163.     IF xpk.Pack(tags) # 0 THEN
  164.       RETURN FALSE; END;
  165.  
  166.   ELSE
  167.     IF fib.type # xpk.typePacked THEN
  168.       io.WriteString("Skipping (already unpacked) ");
  169.       io.WriteString(filename); io.WriteLn;
  170.       RETURN FALSE;
  171.     END;
  172.  
  173.     len := str.Length(filename);
  174.     suffix:=FALSE;
  175.     str.Cut(filename,len-5,5,help); str.Upper(help);
  176.     IF (len>4) & (help = ".XPK") THEN
  177.       COPY(NameBuf,filename);
  178.       NameBuf[len-5]:=CHR(0);
  179.       suffix:=TRUE;
  180.     END;
  181.  
  182.     IF xpk.Unpack(tags) # 0 THEN
  183.       RETURN FALSE; END;
  184.   END;
  185.  
  186.  
  187.   IF ~suffix THEN
  188.     IF ~d.DeleteFile(filename) THEN
  189.       ErrBuf := "Cannot delete input file";
  190.       RETURN FALSE;
  191.     END;
  192.     IF ~d.Rename(NameBuf,filename) THEN
  193.       ErrBuf := "Cannot rename tempfile";
  194.       RETURN FALSE;
  195.     END;
  196.   END;
  197. END DoFile;
  198.  
  199.  
  200. PROCEDURE DoArg(name: ARRAY OF CHAR);
  201. VAR
  202.   fr, entry: DirEntryPtr;
  203.   lock, prev: d.FileLockPtr;
  204.   buf: ARRAY 200 OF CHAR;
  205.   fib: d.FileInfoBlockPtr;
  206.   root: DirEntry;
  207. BEGIN
  208.   NEW(fib);
  209.   IF fib = NIL THEN
  210.     ErrBuf:="Out of memory"; error := TRUE;
  211.     RETURN;
  212.   END;
  213.  
  214.   lock := d.Lock(name, d.accessRead);
  215.   IF lock = NIL THEN
  216.     pf.SPrintf2(ErrBuf,"Error %d reading %s",d.IoErr(),s.ADR(name));
  217.     error := TRUE;
  218.     RETURN;
  219.   END;
  220.  
  221.   IF ~d.Examine( lock, fib^) THEN
  222.     d.UnLock( lock );
  223.     pf.SPrintf2(ErrBuf,"Error %d reading %s",d.IoErr(),s.ADR(name));
  224.     error := TRUE;
  225.     RETURN;
  226.   END;
  227.  
  228.   IF fib.dirEntryType<0 THEN
  229.     d.UnLock(lock);
  230.     IF ~DoFile(fib.fileName) THEN error := TRUE; END;
  231.   ELSIF recurse THEN
  232.     io.WriteString("Directory "); io.WriteString(name); io.WriteLn;
  233.     prev:=d.CurrentDir(lock);
  234.  
  235.     entry:=s.ADR(root);
  236.     WHILE d.ExNext(lock,fib^) & ~error DO
  237.       IF d.ctrlC IN e.SetSignal(LONGSET{},LONGSET{d.ctrlC}) THEN
  238.         ErrBuf:=" *** Break"; error := TRUE;
  239.       ELSE
  240.         NEW(entry.next);
  241.         IF entry.next = NIL THEN
  242.           ErrBuf:="Out of memory"; error := TRUE;
  243.         ELSE
  244.           entry:=entry.next;
  245.           COPY(fib.fileName,entry.name);
  246.         END;
  247.       END;
  248.     END;
  249.     entry.next:= NIL;
  250.  
  251.     entry := root.next;
  252.     WHILE entry # NIL DO
  253.       DoArg(entry.name);
  254.       fr:=entry; entry := entry.next; DISPOSE(fr);
  255.     END;
  256.     d.UnLock(d.CurrentDir(prev));
  257.     io.WriteString("Directory end"); io.WriteString(name); io.WriteLn;
  258.   END;
  259. END DoArg;
  260.  
  261.  
  262.  
  263. BEGIN
  264.   ChunkHook.entry := ChunkFunc;
  265. (* $IF SmallData *)
  266.   ChunkHook.data := s.REG(a5); (* preserve for restore in hook function *)
  267. (* $END *)
  268.  
  269.   tags[tInName].data := s.ADR(Arg);
  270.   tags[tOutName].data := s.ADR(NameBuf);
  271.   tags[tChunkHook].data := s.ADR(ChunkHook);
  272.   tags[tGetError].data := s.ADR(ErrBuf);
  273.   tags[tFindMethod].data := s.ADR(Method);
  274.   tags[tPassword].data := NIL;
  275.   argc := arg.NumArgs(); i := 1;
  276.  
  277.   arg.GetArg(0,Method);
  278.   GetBaseName(Method);
  279.   arg.GetArg(1,Arg);
  280.   IF ((argc <2) OR (Arg = "?")) THEN
  281.     End(Usage);
  282.   ELSIF (BaseName # "XPK") THEN
  283.     COPY(BaseName,Method);
  284.   ELSE
  285.     Method := "";
  286.   END;
  287.  
  288.   WHILE (i <= argc) & (Arg[0]="-") DO
  289.      c := 1;
  290.      WHILE Arg[c] # CHR(0) DO
  291.        CASE Arg[c] OF
  292.        'p': INC(i); arg.GetArg(i,Password); tags[tPassword].data := s.ADR(Password); |
  293.        'm': INC(i); arg.GetArg(i,Method); |
  294.        's': suffix := TRUE;  |
  295.        'f': force := TRUE;   |
  296.        'u': unpack := TRUE; tags[tFindMethod].tag := u.ignore; |
  297.        'r': recurse := TRUE; |
  298.         ELSE
  299.           End(Usage);
  300.         END;
  301.        INC(c);
  302.      END;
  303.     INC(i); arg.GetArg(i,Arg);
  304.   END;
  305.   IF i > argc THEN End(Usage); END;
  306.  
  307.   IF (Method="") & ~unpack THEN
  308.     End("Need a packing method, use -m"); END;
  309.  
  310.   WHILE (i <= argc) & ~error DO
  311.      arg.GetArg(i,Arg);
  312.      DoArg(Arg);
  313.      INC(i);
  314.   END;
  315.   IF error THEN End(ErrBuf); END;
  316.  
  317. END Xpk.
  318.  
  319.